RSA functionality

# speaker informativity
# ---------------------
speaker.inf = function(d, alpha, cost = 0) {
  exp(alpha*(log(d) - cost))
}
# speaker likelihood
# ------------------
speaker.lhd = function(rating, degree, m, alpha) {
  numerator = speaker.inf(m[rating, degree], alpha)
  normalize = sum(sapply(m[rating, ], function(i) {speaker.inf(i, alpha)}))
  return(numerator / normalize)
}
# non-normalized posterior
# -----------------------
nn.post = function(rating, degree, m, alpha, useprior) {
  prior = priors[rating, "prior.p"]
  return(speaker.lhd(rating, degree, m, alpha) * prior)
}
# normalized posterior
# --------------------
norm.post = function(rating, degree, m, alpha, useprior) {
  nn = nn.post(rating, degree, m, alpha, useprior)
  normalize = sum(unlist(sapply(seq(1, 5), function(i){nn.post(i, degree, m, alpha, useprior)})))
  return(nn / normalize)
}

Run model functionality

# run.partial()
# ------------
# Run RSA with model1 (entailment) and model2 (entailment + generic)
run.partial = function(d, alpha=1, useprior=F, usenone=F, normalize=F) {
  if (normalize) {
    mat = d %>%
      select(stars, degree, speaker.p) %>%
      spread(degree, speaker.p) %>%
      mutate(hi = hi / sum(hi),
             low = low / sum(low)) %>%
      select(hi, low)
  } else {
    mat = d %>%
      select(stars, degree, speaker.p) %>%
      spread(degree, speaker.p) %>%
      select(hi, low)
  }
  
  if (usenone) {
    mat$none = c(1, 0, 0, 0, 0)
  } 
  
  d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree, 
                                    MoreArgs = list(m = mat, 
                                                    alpha = alpha, 
                                                    useprior = useprior))), 
                  digits=4)
  
  return(d)
}

# run.full()
# ------------
# Run RSA with model3 (full) with alternatives
run.full = function(d, alpha=1, useprior=F, usenone=F, addMid=F, normalize=F) {
  # alpha = scales.entropy[scales.entropy$scale==d$scale[1], ]$Entropy
  if (addMid) {
    if (normalize) {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        mutate(hi1 = hi1 / sum(hi1),
               hi2 = hi2 / sum(hi2),
               mid = mid / sum(mid),
               low1 = low1 / sum(low1),
               low2 = low2 / sum(low2)) %>%
        select(hi1, hi2, mid, low1, low2)    
    } else {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        select(hi1, hi2, mid, low1, low2)    
    }
  } else {
    if (normalize) {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        mutate(hi1 = hi1 / sum(hi1),
               hi2 = hi2 / sum(hi2),
               low1 = low1 / sum(low1),
               low2 = low2 / sum(low2)) %>%
        select(hi1, hi2, low1, low2)
    } else {
      mat = d %>%
        select(stars, degree, speaker.p) %>%
        spread(degree, speaker.p) %>%
        select(hi1, hi2, low1, low2)
    }
  }
  
  if (usenone) {
    mat$none = c(1, 0, 0, 0, 0)
  } 
  
  d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree, 
                                    MoreArgs = list(m = mat, 
                                                    alpha = alpha, 
                                                    useprior = useprior))), 
                  digits=4)
  
  return(d)
}

Tune hyperparams

# tune.alhpa()
# ------------
# d        --> data
# alphas   --> range of alphas to test
# type     --> full or partial model
# useprior --> use uniform prior
# usenone  --> use gener None
tune.alpha = function(d, alphas = seq(from=1, to=10),
                      type="partial", useprior = T,
                      usenone=F, compare.data=NULL, addMid = F, normalize=F) {
  # Tune best alphas
  fit = sapply(alphas, FUN=function(n) {
    if (type == "partial") {
      md = d %>%
        do(run.partial(., alpha=n, useprior=useprior, usenone=usenone, normalize=normalize))
    } else {
      md = d %>%
        do(run.full(., alpha=n, useprior=useprior, usenone=usenone, addMid=addMid, normalize=normalize))
    }
    # Toggle fit to e6 data
    if (!is.null(compare.data)) {
      
      # If we're using e11 data with multiple scalars
      if ("hi1" %in% md$degree) {
        matched.items = which((md[, "scale"] != "some_all" &
                                 (md[, "degree"] == "hi2" | md[, "degree"] == "hi1")) |
                                (md[, "scale"] == "some_all" &
                                   (md[, "degree"] == "hi1" | md[, "degree"] == "low1")))
        md = md[matched.items, ]
        md$degree = ifelse(md$degree == "hi1", "hi", "low")
        stopifnot("listener.p" %in% colnames(compare.data))
      }
      md$listener.p = compare.data$listener.p
    }
    
    # MSE
    return(mean((md$pred - md$listener.p)^2))
  })  
  # get lowest MSE
  best.alpha = which(fit == min(fit))
  return(best.alpha)
}

# Uniform priors
unif.priors = data.frame(stars = seq(1, 5), prior.p = rep(0.2, 5))
emp.priors = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/emp_priors.csv")
priors = unif.priors

scales.entropy = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/scales_entropy.csv")

Model Comparisons

Data for entailment models

speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e8.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e6.csv")
# Combine speaker / listener
data.partial = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)

Data for full model - no alternatives

speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e11.csv")
data.full = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)

Data for full model - alternatives

# made up alts in 'L0_e10a.csv'
# fitted alts in 'L0_e10fittedAlts.csv'
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10fittedAlts.csv")
data.full.extras = left_join(speaker, listener) %>%
  left_join(priors) %>%
  rowwise %>%
  select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
  mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
  group_by(scale)
## Joining by: c("scale", "degree", "stars")
## Warning in left_join_impl(x, y, by$x, by$y): joining factors with different
## levels, coercing to character vector
## Joining by: "stars"
## Warning: Grouping rowwise data frame strips rowwise nature

Match items between studies (full and partial)

matched.items = which((data.full[, "scale"] != "some_all" &
        (data.full[, "degree"] == "hi2" | data.full[, "degree"] == "hi1")) |
       (data.full[, "scale"] == "some_all" &
          (data.full[, "degree"] == "hi1" | data.full[, "degree"] == "low1")))
matched.items.extras = which((data.full.extras[, "scale"] != "some_all" &
        (data.full.extras[, "degree"] == "hi2" | data.full.extras[, "degree"] == "hi1")) |
       (data.full.extras[, "scale"] == "some_all" &
          (data.full.extras[, "degree"] == "hi1" | data.full.extras[, "degree"] == "low1")))

Run comparisons

# Save performance output
performance.output = data.frame(model=rep(NA, 16),
                                cor.e6=rep(NA, 16),
                                cor.e11=rep(NA, 16),
                                normalized=rep(NA, 16))
alphas = rep(NA, 16)
data.full.transfer = data.full[matched.items, ]
data.full.transfer$degree =
  ifelse(data.full.transfer$degree == "hi1", "hi", "low")
# Model 1 - Entailment only models
# --------------------------------
# 1.a)
# Entailment only
# Normalized = T
# alpha tuning = F
alphas[1] = 1
m1.a = data.partial %>%
  do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=T))
# Store output and add e11
m1.a = cbind(m1.a, data.full.transfer$listener.p)
colnames(m1.a)[8] = "e11.listener.p"
performance.output[1, ] = c("m1.a", round(cor(m1.a$listener.p, m1.a$pred), 5),
                            round(cor(m1.a$e11.listener.p, m1.a$pred), 5), T)
# Store plot
m1.a.plot = qplot(stars, listener.p, col=degree, 
      data=m1.a,
      main=paste("m1.a\nalpha: ", alphas[1],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[1, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.b)
# Entailment only
# Normalized = F
# alpha tune = F
alphas[2] = 1
m1.b = data.partial %>%
  do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=F))
# Store output
m1.b = cbind(m1.b, data.full.transfer$listener.p)
colnames(m1.b)[8] = "e11.listener.p"
performance.output[2, ] = c("m1.b", round(cor(m1.b$listener.p, m1.b$pred), 5),
                            round(cor(m1.b$e11.listener.p, m1.b$pred), 5), F)
# Store plot
m1.b.plot = qplot(stars, listener.p, col=degree, 
      data=m1.b,
      main=paste("m1.b\nalpha: ", alphas[2],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[2, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.c)
# Entailment only
# Normalized = T
# alpha tune = T
alphas[3] = tune.alpha(data.partial, normalize=T, compare.data=data.full.transfer)
m1.c = data.partial %>%
  do(run.partial(., alpha = alphas[3], useprior=T, usenone=F, normalize=T))
# Store output
m1.c = cbind(m1.c, data.full.transfer$listener.p)
colnames(m1.c)[8] = "e11.listener.p"
performance.output[3, ] = c("m1.c", round(cor(m1.c$listener.p, m1.c$pred), 5),
                            round(cor(m1.c$e11.listener.p, m1.c$pred), 5), T)
# Store plot
m1.c.plot = qplot(stars, listener.p, col=degree, 
      data=m1.c,
      main=paste("m1.c\nalpha: ", alphas[3],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[3, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 1.d)
# Entailment only
# Normalized = F
# alpha tune = T
alphas[4] = tune.alpha(data.partial, normalize=F)
m1.d = data.partial %>%
  do(run.partial(., alpha = alphas[4], useprior=T, usenone=F, normalize=F))
# Store output
m1.d = cbind(m1.d, data.full.transfer$listener.p)
colnames(m1.d)[8] = "e11.listener.p"
performance.output[4, ] = c("m1.d", round(cor(m1.d$listener.p, m1.d$pred), 5),
                            round(cor(m1.d$e11.listener.p, m1.d$pred), 5), normalized=F)
# Store plot
m1.d.plot = qplot(stars, listener.p, col=degree, 
      data=m1.d,
      main=paste("m1.d\nalpha: ", alphas[4],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[4, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 2 - Entailment + generic none
# --------------------------------
# 2.a)
# Entailment + generic None
# Normalized = T
# alpha tuning = F
alphas[5] = 1
m2.a = data.partial %>%
  do(run.partial(., alpha = alphas[5], useprior=T, usenone=T, normalize=T))
# Store output
m2.a = cbind(m2.a, data.full.transfer$listener.p)
colnames(m2.a)[8] = "e11.listener.p"
performance.output[5, ] = c("m2.a", round(cor(m2.a$listener.p, m2.a$pred), 5),
                            round(cor(m2.a$e11.listener.p, m2.a$pred), 5), T)
# Store plot
m2.a.plot = qplot(stars, listener.p, col=degree, 
      data=m2.a,
      main=paste("m2.a\nalpha: ", alphas[5],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[5, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.b)
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[6] = 1
m2.b = data.partial %>%
  do(run.partial(., alpha = alphas[6], useprior=T, usenone=T, normalize=F))
# Store output
m2.b = cbind(m2.b, data.full.transfer$listener.p)
colnames(m2.b)[8] = "e11.listener.p"
performance.output[6, ] = c("m2.b", round(cor(m2.b$listener.p, m2.b$pred), 5),
                            round(cor(m2.b$e11.listener.p, m2.b$pred), 5), F)
# Store plot
m2.b.plot = qplot(stars, listener.p, col=degree, 
      data=m2.b,
      main=paste("m2.b\nalpha: ", alphas[6],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[6, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.c)
# Entailment + generic None
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[7] = tune.alpha(data.partial, normalize=T, compare.data=NULL)
m2.c = data.partial %>%
  do(run.partial(., alpha = alphas[7], useprior=T, usenone=T, normalize=T))
# Store output
m2.c = cbind(m2.c, data.full.transfer$listener.p)
colnames(m2.c)[8] = "e11.listener.p"
performance.output[7, ] = c("m2.c", round(cor(m2.c$listener.p, m2.c$pred), 5),
                            round(cor(m2.c$e11.listener.p, m2.c$pred), 5), T)
# Store plot
m2.c.plot = qplot(stars, listener.p, col=degree, 
      data=m2.c,
      main=paste("m2.c\nalpha: ", alphas[7],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[7, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 2.d)
# Entailment + generic None
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[8] = tune.alpha(data.partial, normalize=F)
m2.d = data.partial %>%
  do(run.partial(., alpha = alphas[8], useprior=T, usenone=T, normalize=F))
# Store output
m2.d = cbind(m2.d, data.full.transfer$listener.p)
colnames(m2.d)[8] = "e11.listener.p"
performance.output[8, ] = c("m2.d", round(cor(m2.d$listener.p, m2.d$pred), 5),
                            round(cor(m2.d$e11.listener.p, m2.d$pred), 5), F)
# Store plot
m2.d.plot = qplot(stars, listener.p, col=degree, 
      data=m2.d,
      main=paste("m2.d\nalpha: ", alphas[8],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[8, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 3 - Empirical alternatives
# --------------------------------
# 3.a)
# Emp alts
# Normalized = T
# alpha tuning = F
alphas[9] = 1
m3.a = data.full %>%
  do(run.full(., alpha = alphas[9], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.a.matched = m3.a[matched.items, ]
m3.a.matched$degree = ifelse(m3.a.matched$degree == "hi1", "hi", "low")
m3.a.matched = cbind(m3.a.matched, data.partial$listener.p)
all(m3.a.matched$scale == data.partial$scale & m3.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.a.matched)[length(colnames(m3.a.matched))] = "e6.listener.p"
# Store output
performance.output[9, ] = c("m3.a", round(cor(m3.a.matched$e6.listener.p, m3.a.matched$pred), 5),
                            round(cor(m3.a.matched$listener.p, m3.a.matched$pred), 5), T)
# Store plot
m3.a.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m3.a.matched,
      main=paste("m3.a\nalpha: ", alphas[9],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[9, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.b)
# Emp alts
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[10] = 1
m3.b = data.full %>%
  do(run.full(., alpha = alphas[10], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.b.matched = m3.b[matched.items, ]
m3.b.matched$degree = ifelse(m3.b.matched$degree == "hi1", "hi", "low")
m3.b.matched = cbind(m3.b.matched, data.partial$listener.p)
all(m3.b.matched$scale == data.partial$scale & m3.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.b.matched)[length(colnames(m3.b.matched))] = "e6.listener.p"
# Store output
performance.output[10, ] = c("m3.b", round(cor(m3.b.matched$e6.listener.p, m3.b.matched$pred), 5),
                             round(cor(m3.b.matched$listener.p, m3.b.matched$pred), 5), F)
# Store plot
m3.b.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m3.b.matched,
      main=paste("m3.b\nalpha: ", alphas[10],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[10, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.c)
# Emp alts
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial for e6 or NULL for e11
alphas[11] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=T)
m3.c = data.full %>%
  do(run.full(., alpha = alphas[11], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.c.matched = m3.c[matched.items, ]
m3.c.matched$degree = ifelse(m3.c.matched$degree == "hi1", "hi", "low")
m3.c.matched = cbind(m3.c.matched, data.partial$listener.p)
all(m3.c.matched$scale == data.partial$scale & m3.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.c.matched)[length(colnames(m3.c.matched))] = "e6.listener.p"
# Store output
performance.output[11, ] = c("m3.c", round(cor(m3.c.matched$e6.listener.p, m3.c.matched$pred), 5),
                             round(cor(m3.c.matched$listener.p, m3.c.matched$pred), 5), T)

# Store plot 2 - both e6 and e11 data
m3.c.jointD = m3.c.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m3.c.jointD$study = ifelse(m3.c.jointD$study == "e6.listener.p", "e6", "e11")
m3.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m3.c.jointD,
      main=paste("m3.c\nalpha: ", alphas[11],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 3.d)
# Emp alts
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[12] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=F)
m3.d = data.full %>%
  do(run.full(., alpha = alphas[12], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.d.matched = m3.d[matched.items, ]
m3.d.matched$degree = ifelse(m3.d.matched$degree == "hi1", "hi", "low")
m3.d.matched = cbind(m3.d.matched, data.partial$listener.p)
all(m3.d.matched$scale == data.partial$scale & m3.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.d.matched)[length(colnames(m3.d.matched))] = "e6.listener.p"
# Store output
performance.output[12, ] = c("m3.d", round(cor(m3.d.matched$e6.listener.p, m3.d.matched$pred), 5),
                             round(cor(m3.d.matched$listener.p, m3.d.matched$pred), 5), F)

# Store plot 2 - both e6 and e11 data
m3.d.jointD = m3.d.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m3.d.jointD$study = ifelse(m3.d.jointD$study == "e6.listener.p", "e6", "e11")
m3.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m3.d.jointD,
      main=paste("m3.d\nalpha: ", alphas[12],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# Model 4 - Empirical alternatives + extras
# -----------------------------------------
# 4.a)
# Emp alts + extras
# Normalized = T
# alpha tuning = F
alphas[13] = 1
m4.a = data.full.extras %>%
  do(run.full(., alpha = alphas[13], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.a.matched = m4.a[matched.items.extras, ]
m4.a.matched$degree = ifelse(m4.a.matched$degree == "hi1", "hi", "low")
m4.a.matched = cbind(m4.a.matched, data.partial$listener.p)
all(m4.a.matched$scale == data.partial$scale & m4.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.a.matched)[length(colnames(m4.a.matched))] = "e6.listener.p"
# Store output
performance.output[13, ] = c("m4.a", round(cor(m4.a.matched$e6.listener.p, m4.a.matched$pred), 5), 
                             round(cor(m4.a.matched$listener.p, m4.a.matched$pred), 5), T)
# Store plot
m4.a.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m4.a.matched,
      main=paste("m4.a\nalpha: ", alphas[13],
                 "\nNormalized = ", T,
                 "\nCorr = ", performance.output[13, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 4.b)
# Emp alts + extras
# Normalized = F
# alpha tune = F
alphas[14] = 1
m4.b = data.full.extras %>%
  do(run.full(., alpha = alphas[14], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.b.matched = m4.b[matched.items.extras, ]
m4.b.matched$degree = ifelse(m4.b.matched$degree == "hi1", "hi", "low")
m4.b.matched = cbind(m4.b.matched, data.partial$listener.p)
all(m4.b.matched$scale == data.partial$scale & m4.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.b.matched)[length(colnames(m4.b.matched))] = "e6.listener.p"
# Store output
performance.output[14, ] = c("m4.b", round(cor(m4.b.matched$e6.listener.p, m4.b.matched$pred), 5), 
                             round(cor(m4.b.matched$listener.p, m4.b.matched$pred), 5), F)
# Store plot
m4.b.plot = qplot(stars, e6.listener.p, col=degree, 
      data=m4.b.matched,
      main=paste("m4.b\nalpha: ", alphas[14],
                 "\nNormalized = ", F,
                 "\nCorr = ", performance.output[14, 2]),
      ylab="Posterior p(rating | word)") + 
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

# 4.c)
# Emp alts + extras
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[15] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=T)
m4.c = data.full.extras %>%
  do(run.full(., alpha = alphas[15], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.c.matched = m4.c[matched.items.extras, ]
m4.c.matched$degree = ifelse(m4.c.matched$degree == "hi1", "hi", "low")
m4.c.matched = cbind(m4.c.matched, data.partial$listener.p)
all(m4.c.matched$scale == data.partial$scale & m4.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.c.matched)[length(colnames(m4.c.matched))] = "e6.listener.p"
# Store output (e11 and e6)
performance.output[15, ] = c("m4.c", round(cor(m4.c.matched$e6.listener.p, m4.c.matched$pred), 5),
                             round(cor(m4.c.matched$listener.p, m4.c.matched$pred), 5), T)

# Store plot 2 - both e6 and e11 data
m4.c.jointD = m4.c.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m4.c.jointD$study = ifelse(m4.c.jointD$study == "e6.listener.p", "e6", "e11")
m4.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m4.c.jointD,
      main=paste("m4.c\nalpha: ", alphas[15],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)


# 4.d)
# Emp alts + extras
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[16] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=F)
m4.d = data.full.extras %>%
  do(run.full(., alpha = alphas[16], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.d.matched = m4.d[matched.items.extras, ]
m4.d.matched$degree = ifelse(m4.d.matched$degree == "hi1", "hi", "low")
m4.d.matched = cbind(m4.d.matched, data.partial$listener.p)
all(m4.d.matched$scale == data.partial$scale & m4.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.d.matched)[length(colnames(m4.d.matched))] = "e6.listener.p"
# Store output
performance.output[16, ] = c("m4.d", round(cor(m4.d.matched$e6.listener.p, m4.d.matched$pred), 5),
                             round(cor(m4.d.matched$listener.p, m4.d.matched$pred), 5), F)

# Store plot 2 - both e6 and e11 data
m4.d.jointD = m4.d.matched %>%
  gather(study, listener.pred, listener.p, e6.listener.p)
m4.d.jointD$study = ifelse(m4.d.jointD$study == "e6.listener.p", "e6", "e11")
m4.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
      data=m4.d.jointD,
      main=paste("m4.d\nalpha: ", alphas[16],
                 "\nNormalized = ", T,
                 ylab="Posterior p(rating | word)")) +
  ylim(0, 1) +
  facet_wrap(~scale) + 
  geom_line(aes(y = pred), lty = 4)

Discussion

Interpreting the output table:

m1: Entailment only models (i.e. “some_all” scale only includes “some”, “all”)

m2: Entailment + generic None models (i.e. “some_all” scale includes “none”, “some”, “all”)

m3: Full model with empirical alternatives (i.e. “some_all” scale includes “none”, “some”, “most”, all“)

m4: Entailment + empirical alternatives + additional fitted scalar (i.e. “some_all” scale includes “none”, “some”, “mid”, “most”, all“)

a: Normalized literal listener values before running RSA, no alpha tuning

b: No normalization for literal listener values before running RSA, no alpha tuning

c: Normalized literal listener values before running RSA, alpha tuning

d: No normalization for literal listener values before running RSA, alpha tuning

performance.output$cor.e6 = as.numeric(performance.output$cor.e6)
performance.output$cor.e11 = as.numeric(performance.output$cor.e11)
performance.output = performance.output %>%
  mutate(avg.corr =
           (cor.e6 + cor.e11) / 2)
performance.output = cbind(performance.output, alphas)
# reorder columns
performance.output = performance.output[, c(1, 2, 3, 5, 4, 6)]
grid.table(performance.output)

Interpretation

Overall results

Across e6 and e11 pragmatic listener judgements we see model fit improve as we add more alternatives: The largest improvement occurs when we first include the empirically derived salient alternatives (correlations jump +0.23). Have a look at the m2 vs m3 correlation for models with pre-RSA normalization below (c models)

# Tuned, normalized models r
barchart.d = performance.output[c(3, 7, 11, 15), ] %>%
  gather(study, cor, cor.e6, cor.e11)
barchart.d$cor = as.numeric(barchart.d$cor)
ggplot(barchart.d, aes(x=model, y=cor, fill=study)) + 
  geom_bar(stat="identity", position="dodge") +
  ylim(0, 1) + 
  ggtitle("Model fit for e6 and e11\npragmatic listener judgments") +
  geom_text(aes(x=model, y=as.numeric(cor) + 0.025, label=round(cor, 3), col=(study)))

Here’s a closer look at the improvement in fit between between normalized m2 and m3.

m2.c.plot

m3.c.jointPlot

Including alternatives

Importantly, we also see improvements with the addition of ‘fitted’ alternatives in m4 see the plots below - especially in matching weaker scalar distriubtions (i.e. ‘some’ in ‘some_all’).

m4.c.jointPlot

Questions:

1) How do we want to deal with e6 vs e11 prag listener judgement differences?

e6 and e11 prag listener judgement differences

2) Normalizing vs not normalizing before running RSA:

Non-normalized models seem to be more sensitive to alpha tuning as the number of alternatives increases (see m4.d and m3.d with alpha = 8). I’m not sure if there is a theoretical consideration here that RSA may want to address? What does it mean to normalize literal listener values prior to computing the posterior? One repercussion is that during normalization we’ll see larger impact from salient alternatives…

3) Coming up with alternatives

I was trying to estimate what seemed liked ‘sensible’ alternatives and decided to try and ‘fit’ the distributions for alternatives using a pseudo gradient descent algorithm - fitting alternatives

How can we interpret some of the more funky alternatives (i.e. memorable_unforgettable, some_all)? Does this scalar family ‘want’ more than one more alternative? That is, maybe the model is telling us that only one additional alternative is not enough…? Can we link this intuition back to entropy measures for the scales?

# entropy measures 
scales.entropy
##                     scale  Entropy
## 1          good_excellent 4.841411
## 2             liked_loved 3.524465
## 3 memorable_unforgettable 4.964536
## 4     palatable_delicious 5.183348
## 5                some_all 3.743334

All plots

m1.a.plot

m1.b.plot

m1.c.plot

m1.d.plot

m2.a.plot

m2.b.plot

m2.c.plot

m2.d.plot

m3.a.plot

m3.b.plot

m3.c.jointPlot

m3.d.jointPlot

m4.a.plot

m4.b.plot

m4.c.jointPlot

m4.d.jointPlot

Other exploration

# bad.predictions = m3.fit.matched$pred > 0 &
#                   m3.fit.matched$e6.listener.p == 0 &
#                   (m3.fit.matched$pred - m3.fit.matched$e6.listener.p > 0.05)